home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / genwrite.scm < prev    next >
Text File  |  1999-04-19  |  9KB  |  265 lines
  1. ;;"genwrite.scm" generic write used by pretty-print and truncated-print.
  2. ;; Copyright (c) 1991, Marc Feeley
  3. ;; Author: Marc Feeley (feeley@iro.umontreal.ca)
  4. ;; Distribution restrictions: none
  5.  
  6. (define (generic-write obj display? width output)
  7.  
  8.   (define (read-macro? l)
  9.     (define (length1? l) (and (pair? l) (null? (cdr l))))
  10.     (let ((head (car l)) (tail (cdr l)))
  11.       (case head
  12.         ((QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING) (length1? tail))
  13.         (else                                        #f))))
  14.  
  15.   (define (read-macro-body l)
  16.     (cadr l))
  17.  
  18.   (define (read-macro-prefix l)
  19.     (let ((head (car l)) (tail (cdr l)))
  20.       (case head
  21.         ((QUOTE)            "'")
  22.         ((QUASIQUOTE)       "`")
  23.         ((UNQUOTE)          ",")
  24.         ((UNQUOTE-SPLICING) ",@"))))
  25.  
  26.   (define (out str col)
  27.     (and col (output str) (+ col (string-length str))))
  28.  
  29.   (define (wr obj col)
  30.  
  31.     (define (wr-expr expr col)
  32.       (if (read-macro? expr)
  33.         (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
  34.         (wr-lst expr col)))
  35.  
  36.     (define (wr-lst l col)
  37.       (if (pair? l)
  38.       (let loop ((l (cdr l))
  39.              (col (and col (wr (car l) (out "(" col)))))
  40.         (cond ((not col) col)
  41.           ((pair? l)
  42.            (loop (cdr l) (wr (car l) (out " " col))))
  43.           ((null? l) (out ")" col))
  44.           (else      (out ")" (wr l (out " . " col))))))
  45.       (out "()" col)))
  46.  
  47.     (cond ((pair? obj)        (wr-expr obj col))
  48.           ((null? obj)        (wr-lst obj col))
  49.           ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
  50.           ((boolean? obj)     (out (if obj "#t" "#f") col))
  51.           ((number? obj)      (out (number->string obj) col))
  52.           ((symbol? obj)      (out (symbol->string obj) col))
  53.           ((procedure? obj)   (out "#[procedure]" col))
  54.           ((string? obj)      (if display?
  55.                                 (out obj col)
  56.                                 (let loop ((i 0) (j 0) (col (out "\"" col)))
  57.                                   (if (and col (< j (string-length obj)))
  58.                                     (let ((c (string-ref obj j)))
  59.                                       (if (or (char=? c #\\)
  60.                                               (char=? c #\"))
  61.                                         (loop j
  62.                                               (+ j 1)
  63.                                               (out "\\"
  64.                                                    (out (substring obj i j)
  65.                                                         col)))
  66.                                         (loop i (+ j 1) col)))
  67.                                     (out "\""
  68.                                          (out (substring obj i j) col))))))
  69.           ((char? obj)        (if display?
  70.                                 (out (make-string 1 obj) col)
  71.                                 (out (case obj
  72.                                        ((#\space)   "space")
  73.                                        ((#\newline) "newline")
  74.                                        (else        (make-string 1 obj)))
  75.                                      (out "#\\" col))))
  76.           ((input-port? obj)  (out "#[input-port]" col))
  77.           ((output-port? obj) (out "#[output-port]" col))
  78.           ((eof-object? obj)  (out "#[eof-object]" col))
  79.           (else               (out "#[unknown]" col))))
  80.  
  81.   (define (pp obj col)
  82.  
  83.     (define (spaces n col)
  84.       (if (> n 0)
  85.         (if (> n 7)
  86.           (spaces (- n 8) (out "        " col))
  87.           (out (substring "        " 0 n) col))
  88.         col))
  89.  
  90.     (define (indent to col)
  91.       (and col
  92.            (if (< to col)
  93.              (and (out (make-string 1 #\newline) col) (spaces to 0))
  94.              (spaces (- to col) col))))
  95.  
  96.     (define (pr obj col extra pp-pair)
  97.       (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
  98.         (let ((result '())
  99.               (left (min (+ (- (- width col) extra) 1) max-expr-width)))
  100.           (generic-write obj display? #f
  101.             (lambda (str)
  102.               (set! result (cons str result))
  103.               (set! left (- left (string-length str)))
  104.               (> left 0)))
  105.           (if (> left 0) ; all can be printed on one line
  106.             (out (reverse-string-append result) col)
  107.             (if (pair? obj)
  108.               (pp-pair obj col extra)
  109.               (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
  110.         (wr obj col)))
  111.  
  112.     (define (pp-expr expr col extra)
  113.       (if (read-macro? expr)
  114.         (pr (read-macro-body expr)
  115.             (out (read-macro-prefix expr) col)
  116.             extra
  117.             pp-expr)
  118.         (let ((head (car expr)))
  119.           (if (symbol? head)
  120.             (let ((proc (style head)))
  121.               (if proc
  122.                 (proc expr col extra)
  123.                 (if (> (string-length (symbol->string head))
  124.                        max-call-head-width)
  125.                   (pp-general expr col extra #f #f #f pp-expr)
  126.                   (pp-call expr col extra pp-expr))))
  127.             (pp-list expr col extra pp-expr)))))
  128.  
  129.     ; (head item1
  130.     ;       item2
  131.     ;       item3)
  132.     (define (pp-call expr col extra pp-item)
  133.       (let ((col* (wr (car expr) (out "(" col))))
  134.         (and col
  135.              (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
  136.  
  137.     ; (item1
  138.     ;  item2
  139.     ;  item3)
  140.     (define (pp-list l col extra pp-item)
  141.       (let ((col (out "(" col)))
  142.         (pp-down l col col extra pp-item)))
  143.  
  144.     (define (pp-down l col1 col2 extra pp-item)
  145.       (let loop ((l l) (col col1))
  146.         (and col
  147.              (cond ((pair? l)
  148.                     (let ((rest (cdr l)))
  149.                       (let ((extra (if (null? rest) (+ extra 1) 0)))
  150.                         (loop rest
  151.                               (pr (car l) (indent col2 col) extra pp-item)))))
  152.                    ((null? l)
  153.                     (out ")" col))
  154.                    (else
  155.                     (out ")"
  156.                          (pr l
  157.                              (indent col2 (out "." (indent col2 col)))
  158.                              (+ extra 1)
  159.                              pp-item)))))))
  160.  
  161.     (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
  162.  
  163.       (define (tail1 rest col1 col2 col3)
  164.         (if (and pp-1 (pair? rest))
  165.           (let* ((val1 (car rest))
  166.                  (rest (cdr rest))
  167.                  (extra (if (null? rest) (+ extra 1) 0)))
  168.             (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
  169.           (tail2 rest col1 col2 col3)))
  170.  
  171.       (define (tail2 rest col1 col2 col3)
  172.         (if (and pp-2 (pair? rest))
  173.           (let* ((val1 (car rest))
  174.                  (rest (cdr rest))
  175.                  (extra (if (null? rest) (+ extra 1) 0)))
  176.             (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
  177.           (tail3 rest col1 col2)))
  178.  
  179.       (define (tail3 rest col1 col2)
  180.         (pp-down rest col2 col1 extra pp-3))
  181.  
  182.       (let* ((head (car expr))
  183.              (rest (cdr expr))
  184.              (col* (wr head (out "(" col))))
  185.         (if (and named? (pair? rest))
  186.           (let* ((name (car rest))
  187.                  (rest (cdr rest))
  188.                  (col** (wr name (out " " col*))))
  189.             (tail1 rest (+ col indent-general) col** (+ col** 1)))
  190.           (tail1 rest (+ col indent-general) col* (+ col* 1)))))
  191.  
  192.     (define (pp-expr-list l col extra)
  193.       (pp-list l col extra pp-expr))
  194.  
  195.     (define (pp-LAMBDA expr col extra)
  196.       (pp-general expr col extra #f pp-expr-list #f pp-expr))
  197.  
  198.     (define (pp-IF expr col extra)
  199.       (pp-general expr col extra #f pp-expr #f pp-expr))
  200.  
  201.     (define (pp-COND expr col extra)
  202.       (pp-call expr col extra pp-expr-list))
  203.  
  204.     (define (pp-CASE expr col extra)
  205.       (pp-general expr col extra #f pp-expr #f pp-expr-list))
  206.  
  207.     (define (pp-AND expr col extra)
  208.       (pp-call expr col extra pp-expr))
  209.  
  210.     (define (pp-LET expr col extra)
  211.       (let* ((rest (cdr expr))
  212.              (named? (and (pair? rest) (symbol? (car rest)))))
  213.         (pp-general expr col extra named? pp-expr-list #f pp-expr)))
  214.  
  215.     (define (pp-BEGIN expr col extra)
  216.       (pp-general expr col extra #f #f #f pp-expr))
  217.  
  218.     (define (pp-DO expr col extra)
  219.       (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
  220.  
  221.     ; define formatting style (change these to suit your style)
  222.  
  223.     (define indent-general 2)
  224.  
  225.     (define max-call-head-width 5)
  226.  
  227.     (define max-expr-width 50)
  228.  
  229.     (define (style head)
  230.       (case head
  231.         ((LAMBDA LET* LETREC DEFINE) pp-LAMBDA)
  232.         ((IF SET!)                   pp-IF)
  233.         ((COND)                      pp-COND)
  234.         ((CASE)                      pp-CASE)
  235.         ((AND OR)                    pp-AND)
  236.         ((LET)                       pp-LET)
  237.         ((BEGIN)                     pp-BEGIN)
  238.         ((DO)                        pp-DO)
  239.         (else                        #f)))
  240.  
  241.     (pr obj col 0 pp-expr))
  242.  
  243.   (if width
  244.     (out (make-string 1 #\newline) (pp obj 0))
  245.     (wr obj 0)))
  246.  
  247. ; (reverse-string-append l) = (apply string-append (reverse l))
  248.  
  249. (define (reverse-string-append l)
  250.  
  251.   (define (rev-string-append l i)
  252.     (if (pair? l)
  253.       (let* ((str (car l))
  254.              (len (string-length str))
  255.              (result (rev-string-append (cdr l) (+ i len))))
  256.         (let loop ((j 0) (k (- (- (string-length result) i) len)))
  257.           (if (< j len)
  258.             (begin
  259.               (string-set! result k (string-ref str j))
  260.               (loop (+ j 1) (+ k 1)))
  261.             result)))
  262.       (make-string i)))
  263.  
  264.   (rev-string-append l 0))
  265.